home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / webmon_1 / modping.bas < prev    next >
Encoding:
BASIC Source File  |  1999-08-02  |  11.5 KB  |  331 lines
  1. Attribute VB_Name = "Module2"
  2. Option Explicit
  3.  
  4.  
  5.             Public Const IP_STATUS_BASE = 11000
  6.             Public Const IP_SUCCESS = 0
  7.             Public Const IP_BUF_TOO_SMALL = (11000 + 1)
  8.             Public Const IP_DEST_NET_UNREACHABLE = (11000 + 2)
  9.             Public Const IP_DEST_HOST_UNREACHABLE = (11000 + 3)
  10.             Public Const IP_DEST_PROT_UNREACHABLE = (11000 + 4)
  11.             Public Const IP_DEST_PORT_UNREACHABLE = (11000 + 5)
  12.             Public Const IP_NO_RESOURCES = (11000 + 6)
  13.             Public Const IP_BAD_OPTION = (11000 + 7)
  14.             Public Const IP_HW_ERROR = (11000 + 8)
  15.             Public Const IP_PACKET_TOO_BIG = (11000 + 9)
  16.             Public Const IP_REQ_TIMED_OUT = (11000 + 10)
  17.             Public Const IP_BAD_REQ = (11000 + 11)
  18.             Public Const IP_BAD_ROUTE = (11000 + 12)
  19.             Public Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13)
  20.             Public Const IP_TTL_EXPIRED_REASSEM = (11000 + 14)
  21.             Public Const IP_PARAM_PROBLEM = (11000 + 15)
  22.             Public Const IP_SOURCE_QUENCH = (11000 + 16)
  23.             Public Const IP_OPTION_TOO_BIG = (11000 + 17)
  24.             Public Const IP_BAD_DESTINATION = (11000 + 18)
  25.             Public Const IP_ADDR_DELETED = (11000 + 19)
  26.             Public Const IP_SPEC_MTU_CHANGE = (11000 + 20)
  27.             Public Const IP_MTU_CHANGE = (11000 + 21)
  28.             Public Const IP_UNLOAD = (11000 + 22)
  29.             Public Const IP_ADDR_ADDED = (11000 + 23)
  30.             Public Const IP_GENERAL_FAILURE = (11000 + 50)
  31.             Public Const MAX_IP_STATUS = 11000 + 50
  32.             Public Const IP_PENDING = (11000 + 255)
  33.             Public Const PING_TIMEOUT = 5000
  34.             Public Const WS_VERSION_REQD = &H101
  35.             Public Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
  36.             Public Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
  37.             Public Const MIN_SOCKETS_REQD = 1
  38.             Public Const SOCKET_ERROR = -1
  39.             Public Const MAX_WSADescription = 256
  40.             Public Const MAX_WSASYSStatus = 128
  41.  
  42.  
  43.             Public Type ICMP_OPTIONS
  44.                 Ttl As Byte
  45.                 Tos As Byte
  46.                 Flags As Byte
  47.                 OptionsSize As Byte
  48.                 OptionsData As Long
  49.                 End Type
  50.                 Dim ICMPOPT As ICMP_OPTIONS
  51.  
  52.  
  53.             Public Type ICMP_ECHO_REPLY
  54.                 Address As Long
  55.                 status As Long
  56.                 RoundTripTime As Long
  57.                 DataSize As Integer
  58.                 Reserved As Integer
  59.                 DataPointer As Long
  60.                 Options As ICMP_OPTIONS
  61.                 Data As String * 250
  62.                 End Type
  63.  
  64.  
  65.             Public Type HOSTENT
  66.                 hName As Long
  67.                 hAliases As Long
  68.                 hAddrType As Integer
  69.                 hLen As Integer
  70.                 hAddrList As Long
  71.                 End Type
  72.  
  73.  
  74.             Public Type WSADATA
  75.                 wVersion As Integer
  76.                 wHighVersion As Integer
  77.                 szDescription(0 To MAX_WSADescription) As Byte
  78.                 szSystemStatus(0 To MAX_WSASYSStatus) As Byte
  79.                 wMaxSockets As Integer
  80.                 wMaxUDPDG As Integer
  81.                 dwVendorInfo As Long
  82.                 End Type
  83.  
  84.  
  85.             Public Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
  86.  
  87.  
  88.             Public Declare Function IcmpCloseHandle Lib "icmp.dll" _
  89.                 (ByVal IcmpHandle As Long) As Long
  90.  
  91.  
  92.             Public Declare Function IcmpSendEcho Lib "icmp.dll" _
  93.                 (ByVal IcmpHandle As Long, _
  94.                 ByVal DestinationAddress As Long, _
  95.                 ByVal RequestData As String, _
  96.                 ByVal RequestSize As Integer, _
  97.                 ByVal RequestOptions As Long, _
  98.                 ReplyBuffer As ICMP_ECHO_REPLY, _
  99.                 ByVal ReplySize As Long, _
  100.                 ByVal Timeout As Long) As Long
  101.  
  102.  
  103.             Public Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
  104.  
  105.  
  106.             Public Declare Function WSAStartup Lib "WSOCK32.DLL" _
  107.                 (ByVal wVersionRequired As Long, _
  108.                 lpWSADATA As WSADATA) As Long
  109.  
  110.  
  111.             Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
  112.  
  113.  
  114.             Public Declare Function gethostname Lib "WSOCK32.DLL" _
  115.                 (ByVal szHost As String, _
  116.                 ByVal dwHostLen As Long) As Long
  117.  
  118.  
  119.             Public Declare Function gethostbyname Lib "WSOCK32.DLL" _
  120.                 (ByVal szHost As String) As Long
  121.  
  122.  
  123.             Public Declare Sub RtlMoveMemory Lib "kernel32" _
  124.                 (hpvDest As Any, _
  125.                 ByVal hpvSource As Long, _
  126.                 ByVal cbCopy As Long)
  127.  
  128.  
  129.             Public Function GetStatusCode(status As Long) As String
  130.  
  131.  
  132.                 Dim msg As String
  133.  
  134.  
  135.                 Select Case status
  136.                     Case IP_SUCCESS: msg = "ip success"
  137.                     Case IP_BUF_TOO_SMALL: msg = "ip buf too_small"
  138.                     Case IP_DEST_NET_UNREACHABLE: msg = "ip dest net unreachable"
  139.                     Case IP_DEST_HOST_UNREACHABLE: msg = "ip dest host unreachable"
  140.                     Case IP_DEST_PROT_UNREACHABLE: msg = "ip dest prot unreachable"
  141.                     Case IP_DEST_PORT_UNREACHABLE: msg = "ip dest port unreachable"
  142.                     Case IP_NO_RESOURCES: msg = "ip no resources"
  143.                     Case IP_BAD_OPTION: msg = "ip bad option"
  144.                     Case IP_HW_ERROR: msg = "ip hw_error"
  145.                     Case IP_PACKET_TOO_BIG: msg = "ip packet too_big"
  146.                     Case IP_REQ_TIMED_OUT: msg = "ip req timed out"
  147.                     Case IP_BAD_REQ: msg = "ip bad req"
  148.                     Case IP_BAD_ROUTE: msg = "ip bad route"
  149.                     Case IP_TTL_EXPIRED_TRANSIT: msg = "ip ttl expired transit"
  150.                     Case IP_TTL_EXPIRED_REASSEM: msg = "ip ttl expired reassem"
  151.                     Case IP_PARAM_PROBLEM: msg = "ip param_problem"
  152.                     Case IP_SOURCE_QUENCH: msg = "ip source quench"
  153.                     Case IP_OPTION_TOO_BIG: msg = "ip option too_big"
  154.                     Case IP_BAD_DESTINATION: msg = "ip bad destination"
  155.                     Case IP_ADDR_DELETED: msg = "ip addr deleted"
  156.                     Case IP_SPEC_MTU_CHANGE: msg = "ip spec mtu change"
  157.                     Case IP_MTU_CHANGE: msg = "ip mtu_change"
  158.                     Case IP_UNLOAD: msg = "ip unload"
  159.                     Case IP_ADDR_ADDED: msg = "ip addr added"
  160.                     Case IP_GENERAL_FAILURE: msg = "ip general failure"
  161.                     Case IP_PENDING: msg = "ip pending"
  162.                     Case PING_TIMEOUT: msg = "ping timeout"
  163.                     Case Else: msg = "unknown msg returned"
  164.                 End Select
  165.  
  166.  
  167.             GetStatusCode = CStr(status) & " [ " & msg & " ]"
  168.             End Function
  169.  
  170.  
  171.  
  172.             Public Function HiByte(ByVal wParam As Integer)
  173.  
  174.  
  175.                 HiByte = wParam \ &H100 And &HFF&
  176.             End Function
  177.  
  178.  
  179.  
  180.  
  181.             Public Function LoByte(ByVal wParam As Integer)
  182.  
  183.  
  184.                 LoByte = wParam And &HFF&
  185.             End Function
  186.  
  187.  
  188.  
  189.             Public Function Ping(szAddress As String, ECHO As ICMP_ECHO_REPLY) As Long
  190.  
  191.  
  192.                 Dim hPort As Long
  193.                 Dim dwAddress As Long
  194.                 Dim sDataToSend As String
  195.                 Dim iOpt As Long
  196.                 sDataToSend = "Echo This"
  197.                 dwAddress = AddressStringToLong(szAddress)
  198.                 Call SocketsInitialize
  199.                 hPort = IcmpCreateFile()
  200.                 If IcmpSendEcho(hPort, _
  201.                 dwAddress, _
  202.                 sDataToSend, _
  203.                 Len(sDataToSend), _
  204.                 0, _
  205.                 ECHO, _
  206.                 Len(ECHO), _
  207.                 PING_TIMEOUT) Then
  208.                 'the ping succeeded,
  209.                 '.Status will be 0
  210.                 '.RoundTripTime is the time in ms for
  211.                 ' the ping to complete,
  212.                 '.Data is the data returned (NULL terminated)
  213.                 '.Address is the Ip address that actually replied
  214.                 '.DataSize is the size of the string in .Data
  215.                 Ping = ECHO.RoundTripTime
  216.             Else: Ping = ECHO.status * -1
  217.             End If
  218.  
  219.  
  220.             Call IcmpCloseHandle(hPort)
  221.             Call SocketsCleanup
  222.             End Function
  223.  
  224.  
  225.  
  226.             Function AddressStringToLong(ByVal tmp As String) As Long
  227.  
  228.  
  229.                 Dim i As Integer
  230.                 Dim parts(1 To 4) As String
  231.                 i = 0
  232.                 'we have to extract each part of the
  233.                 '123.456.789.123 string, delimited by
  234.                 'a period
  235.  
  236.  
  237.                 While InStr(tmp, ".") > 0
  238.                     i = i + 1
  239.                     parts(i) = Mid(tmp, 1, InStr(tmp, ".") - 1)
  240.                     tmp = Mid(tmp, InStr(tmp, ".") + 1)
  241.                 Wend
  242.  
  243.  
  244.                 i = i + 1
  245.                 parts(i) = tmp
  246.  
  247.  
  248.                 If i <> 4 Then
  249.                     AddressStringToLong = 0
  250.                     Exit Function
  251.                 End If
  252.  
  253.  
  254.                 'build the long value out of the
  255.                 'hex of the extracted strings
  256.                 AddressStringToLong = Val("&H" & Right("00" & Hex(parts(4)), 2) & _
  257.                 Right("00" & Hex(parts(3)), 2) & _
  258.                 Right("00" & Hex(parts(2)), 2) & _
  259.                 Right("00" & Hex(parts(1)), 2))
  260.             End Function
  261.  
  262.  
  263.  
  264.             Public Function SocketsCleanup() As Boolean
  265.  
  266.  
  267.                 Dim X As Long
  268.                 X = WSACleanup()
  269.  
  270.  
  271.                 If X <> 0 Then
  272.                     MsgBox "Windows Sockets Error " & Trim$(Str$(X)) & _
  273.                     " occurred in Cleanup.", vbExclamation
  274.                     SocketsCleanup = False
  275.                 Else
  276.                     SocketsCleanup = True
  277.                 End If
  278.  
  279.  
  280.             End Function
  281.  
  282.  
  283.  
  284.             Public Function SocketsInitialize() As Boolean
  285.  
  286.  
  287.                 Dim WSAD As WSADATA
  288.                 Dim X As Integer
  289.                 Dim szLoByte As String, szHiByte As String, szBuf As String
  290.                 X = WSAStartup(WS_VERSION_REQD, WSAD)
  291.  
  292.  
  293.                 If X <> 0 Then
  294.                     MsgBox "Windows Sockets For 32 bit Windows " & _
  295.                     "environments is not successfully responding."
  296.                     SocketsInitialize = False
  297.                     Exit Function
  298.                 End If
  299.  
  300.  
  301.                 If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _
  302.                 (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _
  303.                 HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
  304.                 szHiByte = Trim$(Str$(HiByte(WSAD.wVersion)))
  305.                 szLoByte = Trim$(Str$(LoByte(WSAD.wVersion)))
  306.                 szBuf = "Windows Sockets Version " & szLoByte & "." & szHiByte
  307.                 szBuf = szBuf & " is not supported by Windows " & _
  308.                 "Sockets For 32 bit Windows environments."
  309.                 MsgBox szBuf, vbExclamation
  310.                 SocketsInitialize = False
  311.                 Exit Function
  312.             End If
  313.  
  314.  
  315.  
  316.             If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
  317.                 szBuf = "This application requires a minimum of " & _
  318.                 Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
  319.                 MsgBox szBuf, vbExclamation
  320.                 SocketsInitialize = False
  321.                 Exit Function
  322.             End If
  323.  
  324.  
  325.             SocketsInitialize = True
  326.             End Function
  327.  
  328.  
  329.  
  330.  
  331.